home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Runtime (.scm & .s) / _repr.scm < prev    next >
Encoding:
Text File  |  1992-01-25  |  4.0 KB  |  101 lines  |  [TEXT/gamI]
  1. (##slot-ref (##type-cast p 0) 1))
  2.  
  3. (define (##proc-closure-length p)
  4.   (##fixnum.- (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -2) #x2001))
  5.  
  6. (define (##proc-closure-ref p i)
  7.   (##slot-ref (##type-cast p 0) (##fixnum.+ i 2)))
  8.  
  9. (define (##proc-closure-set! p i v)
  10.   (##slot-set! (##type-cast p 0) (##fixnum.+ i 2) v))
  11.  
  12. (define (##proc-subproc? p)
  13.   (##fixnum.< (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) #x8000))
  14.  
  15. (define (##proc-subproc-tag p)
  16.   (##fixnum.- #x1000 (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -3)))
  17.  
  18. (define (##proc-subproc-parent p)
  19.   (##fixnum.- p (##fixnum.- #x1000 (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -3))))
  20.  
  21. (define (##proc-return-dyn-env? p)
  22.   (##fixnum.= (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 0) 0))
  23.  
  24. (define (##proc-return-fs p)
  25.   (let ((x (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 0)))
  26.     (if (##fixnum.= x 0)
  27.       2 ; dynamic environment frame size
  28.       (##fixnum.ash (##fixnum.modulo x #x8000) -2))))
  29.  
  30. (define (##proc-return-link p)
  31.   (##fixnum.- (##proc-return-fs p)
  32.               (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 1) -2)))
  33.  
  34. (define (##proc-debug-info p)
  35.   (let ((len (##fixnum.- (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -2) #x2000)))
  36.     (##vector-ref (##type-cast p (type-subtyped)) (##fixnum.- len 2))))
  37.  
  38. ;------------------------------------------------------------------------------
  39.  
  40. (define (##continuation->frame c)
  41.   (let ((v (##proc-closure-ref c 1))
  42.         (r (##proc-closure-ref c 0))
  43.         (d (##proc-closure-ref c 2)))
  44.     (let ((x (##make-vector 4 #f)))
  45.       (##vector-set! x 0 v)
  46.       (##vector-set! x 1 r)
  47.       (##vector-set! x 2 d)
  48.       (##vector-set! x 3 1)
  49.       x)))
  50.  
  51. (define (##frame-ret f)
  52.   (##vector-ref f 1))
  53.  
  54. (define (##frame-dyn-env f)
  55.   (##vector-ref f 2))
  56.  
  57. (define (##frame-fs f)
  58.   (##proc-return-fs (##vector-ref f 1)))
  59.  
  60. (define (##frame-stk-ref f i)
  61.   (##vector-ref (##vector-ref f 0)
  62.                 (##fixnum.- (##fixnum.+ (##vector-ref f 3)
  63.                                         (##proc-return-fs (##vector-ref f 1)))
  64.                             i)))
  65.  
  66. (define (##frame-stk-set! f i v)
  67.   (##vector-set! (##vector-ref f 0)
  68.                  (##fixnum.- (##fixnum.+ (##vector-ref f 3)
  69.                                          (##proc-return-fs (##vector-ref f 1)))
  70.                              i)
  71.                  v))
  72.  
  73. (define (##frame-next f)
  74.   (let ((v (##vector-ref f 0))
  75.         (r (##vector-ref f 1))
  76.         (d (##vector-ref f 2))
  77.         (o (##vector-ref f 3)))
  78.     (let* ((o* (##fixnum.+ o (##proc-return-fs r)))
  79.            (r* (##vector-ref v (##fixnum.- o* (##proc-return-link r))))
  80.            (d* (if (##proc-return-dyn-env? r)
  81.                  (##vector-ref v (##fixnum.- o* 2))
  82.                  d)))
  83.       (if (##fixnum.< o* (##vector-length v))
  84.         (let ((x (##make-vector 4 #f)))
  85.           (##vector-set! x 0 v)
  86.           (##vector-set! x 1 r*)
  87.           (##vector-set! x 2 d*)
  88.           (##vector-set! x 3 o*)
  89.           x)
  90.         (let ((v* (##vector-ref v 0)))
  91.           (if v*
  92.             (let ((x (##make-vector 4 #f)))
  93.               (##vector-set! x 0 v*)
  94.               (##vector-set! x 1 r*)
  95.               (##vector-set! x 2 d*)
  96.               (##vector-set! x 3 1)
  97.               x)
  98.             #f))))))
  99.  
  100. ;------------------------------------------------------------------------------
  101.